COMMENT ⊗   VALID 00005 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	ENTRY
C00004 00003	INTERNAL INTEGER RPDEPTH ! current depth inside recprn
C00007 00004	INTERNAL RECURSIVE PROCEDURE RECPRN(RPTR(ANY_CLASS) R)
C00009 00005	INTERNAL RECURSIVE PROCEDURE PRINTX(INTEGER RFD)
C00014 ENDMK
C⊗;
ENTRY;

BEGIN "PRINTX"
REQUIRE "ABBREV.SAI[AL,HE]" SOURCE_FILE;
REQUIRE "MACROS.SAI[AL,HE]" SOURCE_FILE;
REQUIRE "STCODE.DEF[AL,HE]" SOURCE_FILE;
REQUIRE "RECAUX.HDR[AL,HE]" SOURCE_FILE;
REQUIRE "REFBTS.DEF[AL,HE]" SOURCE_FILE;
REQUIRE "LEPAUX.HDR[AL,HE]" SOURCE_FILE;

EXTERNAL RECURSIVE PROCEDURE RECPRN(RPTR(ANY_CLASS) R);
EXTERNAL RECURSIVE PROCEDURE PRINTX(INTEGER RFD);

INTERNAL STRING SIMPLE PROCEDURE TBLKSUPPRESS(STRING S);
	BEGIN
	! a quicker way is to use SCAN, but I don't want to require
	  any break tables;
	STRING SS;INTEGER I,J;
	SS←S;J←0;I←0;
	WHILE LENGTH(SS) DO
		BEGIN
		I←I+1;
		IF LOP(SS)≠" " THEN J←I;
		END;
	RETURN(IF J=0 THEN NULL ELSE S[1 FOR J]);
	END;

DEFINE H1(X) "<>" = <(X LSH -18)>;
DEFINE H2(X) "<>" = <(X LAND '777777)>;

IFCR FALSE THENC

SIMPLE BOOLEAN PROCEDURE RRPTRP;
	START_CODE
	EXTERNAL INTEGER SPRPDA,PRNREC;
	LABEL XIT,L;
	MOVE  5,-3('12);
	MOVEI	1,0;
	MOVEI  4,PRNREC;
	HRRZ  4,-1(4); ! PRNREC is internal;
	SKIPA 2,('12); ! static link;
L:	HRRZ  2,(2);
	JUMPE 2,XIT;
	CAIE  2,-1;
	CAIN  2,SPRPDA;
	JRST  XIT;
	HLRZ  3,1(2); ! PDA;
	CAIN  3,(4);
	CAME  5,-2(2);
	JRST  L;
	MOVEI 1,1;
XIT:	END;
ENDC

INTERNAL INTEGER RPDEPTH; ! current depth inside recprn;
INTERNAL INTEGER RPDMAX; ! max depth to which will "expand" record printing;
SIMPLE PROCEDURE INIRPD;
	BEGIN RPDEPTH←0;RPDMAX←4;END;
REQUIRE INIRPD INITIALIZATION;

RCLASS RPPRC(INTEGER RC,PROC;RANY L,R);

INTERNAL RPTR(RPPRC) RPTREE;

BOOLEAN PROCEDURE RPTS(INTEGER RC;REFERENCE RANY RP;INTEGER PROC(0));
	BEGIN
	RANY RPP;
	RPP←RPTREE;
	RP←NULL_RECORD;
	WHILE RPP≠NULL_RECORD DO
		BEGIN
		RP←RPP;
		IF RC=RPPRC:RC[RP] THEN
			BEGIN
			IF PROC THEN RPPRC:PROC[RP]←PROC;
			RETURN(TRUE);
			END;
		IF RC<RPPRC:RC[RP] THEN 
			RPP←RPPRC:L[RP]
		ELSE
			RPP←RPPRC:R[RP];
		END;
	IF ¬PROC THEN RETURN(FALSE);
		
	RPP←NEW_RECORD(RPPRC);
	RPPRC:RC[RPP]←RC;
	RPPRC:PROC[RPP]←PROC;
	IF RP=NULL_RECORD THEN
		RP←RPTREE←RPP
	ELSE
		BEGIN
		IF RC<RPPRC:RC[RP] THEN
			RPPRC:L[RP]←RPP
		ELSE 
			RPPRC:R[RP]←RPP;
		END;
	RETURN(TRUE);
	END;

INTERNAL PROCEDURE SETRPM(INTEGER RC,PROC);
	BEGIN
	RPTR(RPPRC) RP;
	IF PROC=0 THEN
		BEGIN
		IF RPTS(RC,RP) THEN
			RPPRC:PROC[RP]←0;
		END
	ELSE
		RPTS(RC,RP,PROC);
	END;

BOOLEAN PROCEDURE RPMSCH(INTEGER I;REFERENCE INTEGER PR);
	BEGIN
	RPTR(RPPRC) RP;
	IF RPTS(I,RP) THEN
		BEGIN
		PR←RPPRC:PROC[RP];
		RETURN(TRUE);
		END
	ELSE
		RETURN(FALSE);
	END;

INTERNAL RECURSIVE PROCEDURE RECPRN(RPTR(ANY_CLASS) R);
	BEGIN
	INTEGER I,J,N,K,DS;
	ON_BLOCK_EXIT_DO(RPDEPTH←DS);
	DS←RPDEPTH;RPDEPTH←RPDEPTH+1;
	I←RECTYPE(R);
	IF I=0 THEN 
		BEGIN
		PRINT("NULL_RECORD");
		RETURN;
		END;
	IF RPDEPTH>RPDMAX THEN
		BEGIN
		PRINT(CVRTS(I),".",MEM[LOC(R)]);
		RETURN;
		END;
	IF RPMSCH(I,J) THEN
		BEGIN
		START_CODE
		SALACS;
		PUSH	P,R;
		PUSHJ	P,@J;
		END;
		RETURN;
		END;

	N←RECLEN(R);K←MEM[LOC(R)];
	I←LOC($CLASS:TYPARR[$RECTYPE(R)][0]);
	PRINT("[");
	FOR J←1 STEP 1 UNTIL N DO
		BEGIN "PRRFLD"
		PRINTX((MEMORY[I+J] LAND '777777000000)+K+J);
		IF J<N THEN PRINT(",");
		END;
	PRINT("]");
	END;

RECURSIVE PROCEDURE PCELL(RPTR(CELL) C);
	BEGIN
	INTEGER I;
	I←RECTYPE(CELL:CDR[C]);
	IF I=LOC(CELL) ∨ I=0 THEN
		BEGIN
		PRINT("(");
		DO 	BEGIN
			RECPRN(CELL:CAR[C]);
			C←CELL:CDR[C];
			IF 0≠RECTYPE(C)≠LOC(CELL) THEN
				BEGIN
				PRINT(".");
				RECPRN(CELL:CDR[C]);
				DONE;
				END
			ELSE
				PRINT(" ");
			END UNTIL C=NULL_RECORD;
		PRINT(")");
		END
	ELSE
		BEGIN
		RECPRN(CELL:CAR[C]);
		PRINT(".");
		RECPRN(CELL:CDR[C]);
		END;
	END;			

INITIALIZE(SETRPM(LOC(CELL),LOC(PCELL)));
INTERNAL RECURSIVE PROCEDURE PRINTX(INTEGER RFD);
	BEGIN
	INTEGER TYP;
	STRING S;
	SIMPLE PROCEDURE UNIMPPRT(STRING S);
		BEGIN
		PRINT("<",S,":",CVOS(RFD),">");
		END;
	TYP← (RFD LSH -23) LAND '77;
	IF ITEMB_ON(RFD) THEN
		BEGIN
		IF ARY2B_ON(RFD) THEN
			UNIMPPRT("itemvar array ")
		ELSE
			PRINT(MEMORY[RFD,ITEMVAR]);
		RETURN
		END;

	IF PROCB_ON(RFD) THEN
		BEGIN
		UNIMPPRT("procedure");
		RETURN;
		END;
	IF TYP > MXSTYP THEN 
		BEGIN
		UNIMPPRT("array");
		RETURN;
		END;
	CASE TYP OF
		BEGIN

	[0]	PRINT("type 0");
	[1]	PRINT("type 1");
	[2]	PRINT("type 2");
	[3]	BEGIN
		STRING ST;
		MEMORY[LOCATION(ST)]←MEMORY[RFD];
		MEMORY[LOCATION(ST)-1]←MEMORY[RFD-1];
		PRINT(ST);
		END;
	[4]	PRINT(TBLKSUPPRESS(CVG(MEMORY[RFD,REAL])));
	[5]	PRINT(MEMORY[RFD]);
	[6]	PRINT(MEMORY[RFD,SET]);
	[7]	PRINT(MEMORY[RFD,LIST]);
	[8]	UNIMPPRT("PROCEDURE ITEM");
	[9]	UNIMPPRT("PROCESS ITEM");
	[10]	UNIMPPRT("EVENT ITEM");
	[11]	UNIMPPRT("CONTEXT");

	[12]	BEGIN
		IF BINDB_ON(RFD) THEN
			PRINT("@< ∃ ")
		ELSE IF QUESB_ON(RFD) THEN
			PRINT("@< ? ")
		ELSE 
			PRINT("@< ");
		IF REFB_ON(RFD) THEN
			PRINT("@",CVOS(RFD LAND '777777777),":")
		ELSE	
			PRINT(" $ ");
		IF ¬BINDB_ON(RFD) THEN
			PRINTX(MEM[RFD]);
		PRINT(">");
		END;

	[13]	START_CODE
		SALACS;
		PUSH P,@RFD;
		PUSHJ P,RECPRN;
		END

		END;
	END;

END "PRINTX"